home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 501-525 / disk_524 / kamin / src.lzh / smalltalk.c < prev   
C/C++ Source or Header  |  1991-06-28  |  29KB  |  1,300 lines
  1. /* Output from p2c, the Pascal-to-C translator */
  2. /* From input file "smalltalk.p" */
  3.  
  4.  
  5. /*****************************************************************
  6.  *                     DECLARATIONS                              *
  7.  *****************************************************************/
  8.  
  9. #include <p2c/p2c.h>
  10.  
  11.  
  12. #define NAMELENG        30   /* Maximum length of a name */
  13. #define MAXNAMES        300   /* Maximum number of different names */
  14. #define MAXINPUT        5000   /* Maximum length of an input */
  15.  
  16. #define PROMPT          "-> "
  17. #define PROMPT2         "> "
  18. #define COMMENTCHAR     ";"
  19.  
  20. #define TABCODE         9   /* in ASCII */
  21.  
  22.  
  23. typedef Char NAMESTRING[NAMELENG];
  24.  
  25. /* a NAME is an index in printNames */
  26.  
  27. typedef enum {
  28.   IFOP, WHILEOP, SETOP, BEGINOP, NEWOP, PLUSOP, MINUSOP, TIMESOP, DIVOP, EQOP,
  29.   LTOP, GTOP, PRINTOP
  30. } BUILTINOP;
  31.  
  32.  
  33. typedef enum {
  34.   INT, SYM, USER
  35. } STVALUETYPE;
  36.  
  37. typedef struct STVALUEREC {
  38.   struct CLASSREC *owner;
  39.   STVALUETYPE vtype;
  40.   union {
  41.     long intval;
  42.     short symval;
  43.     struct ENVREC *userval;
  44.   } UU;
  45. } STVALUEREC;
  46.  
  47. typedef enum {
  48.   VALEXP, VAREXP, APEXP
  49. } EXPTYPE;
  50.  
  51. typedef struct EXPREC {
  52.   EXPTYPE etype;
  53.   union {
  54.     STVALUEREC *valu;
  55.     short varble;
  56.     struct {
  57.       short optr;
  58.       struct EXPLISTREC *args;
  59.     } U2;
  60.   } UU;
  61. } EXPREC;
  62.  
  63. typedef struct EXPLISTREC {
  64.   EXPREC *head;
  65.   struct EXPLISTREC *tail;
  66. } EXPLISTREC;
  67.  
  68. typedef struct VALUELISTREC {
  69.   STVALUEREC *head;
  70.   struct VALUELISTREC *tail;
  71. } VALUELISTREC;
  72.  
  73. typedef struct NAMELISTREC {
  74.   short head;
  75.   struct NAMELISTREC *tail;
  76. } NAMELISTREC;
  77.  
  78. typedef struct ENVREC {
  79.   NAMELISTREC *vars;
  80.   VALUELISTREC *values;
  81. } ENVREC;
  82.  
  83. typedef struct FUNDEFREC {
  84.   short funname;
  85.   NAMELISTREC *formals;
  86.   EXPREC *body;
  87.   struct FUNDEFREC *nextfundef;
  88. } FUNDEFREC;
  89.  
  90. typedef struct CLASSREC {
  91.   short clname;
  92.   struct CLASSREC *clsuper;
  93.   NAMELISTREC *clrep;
  94.   FUNDEFREC *exported;
  95.   struct CLASSREC *nextclass;
  96. } CLASSREC;
  97.  
  98.  
  99. Static FUNDEFREC *fundefs;
  100. Static CLASSREC *classes;
  101.  
  102. Static ENVREC *globalEnv;
  103.  
  104. Static EXPREC *currentExp;
  105.  
  106. Static Char userinput[MAXINPUT];
  107. Static short inputleng, pos_;
  108.  
  109. Static NAMESTRING printNames[MAXNAMES];
  110. Static short numNames, numBuiltins, numCtrlOps;
  111.  
  112. Static short SELF;
  113.  
  114. Static CLASSREC *OBJECTCLASS;
  115. Static STVALUEREC *objectInst;
  116.  
  117. Static STVALUEREC *trueValue, *falseValue;
  118.  
  119. Static boolean quittingtime;
  120.  
  121.  
  122. /*****************************************************************
  123.  *                     DATA STRUCTURE OP'S                       *
  124.  *****************************************************************/
  125.  
  126. /* mkVALEXP - return an EXP of type VALEXP with valu v           */
  127. Static EXPREC *mkVALEXP(v)
  128. STVALUEREC *v;
  129. {
  130.   EXPREC *e;
  131.  
  132.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  133.   e->etype = VALEXP;
  134.   e->UU.valu = v;
  135.   return e;
  136. }  /* mkVALEXP */
  137.  
  138.  
  139. /* mkVAREXP - return an EXP of type VAREXP with varble nm        */
  140. Static EXPREC *mkVAREXP(nm)
  141. short nm;
  142. {
  143.   EXPREC *e;
  144.  
  145.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  146.   e->etype = VAREXP;
  147.   e->UU.varble = nm;
  148.   return e;
  149. }  /* mkVAREXP */
  150.  
  151.  
  152. /* mkAPEXP - return EXP of type APEXP w/ optr op and args el     */
  153. Static EXPREC *mkAPEXP(op, el)
  154. short op;
  155. EXPLISTREC *el;
  156. {
  157.   EXPREC *e;
  158.  
  159.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  160.   e->etype = APEXP;
  161.   e->UU.U2.optr = op;
  162.   e->UU.U2.args = el;
  163.   return e;
  164. }  /* mkAPEXP */
  165.  
  166.  
  167. /* mkINT - return an STVALUE with integer value n                */
  168. Static STVALUEREC *mkINT(n)
  169. long n;
  170. {
  171.   STVALUEREC *newval;
  172.  
  173.   newval = (STVALUEREC *)Malloc(sizeof(STVALUEREC));
  174.   newval->owner = OBJECTCLASS;
  175.   newval->vtype = INT;
  176.   newval->UU.intval = n;
  177.   return newval;
  178. }  /* mkINT */
  179.  
  180.  
  181. /* mkSYM - return an STVALUE with symbol value s                 */
  182. Static STVALUEREC *mkSYM(s)
  183. short s;
  184. {
  185.   STVALUEREC *newval;
  186.  
  187.   newval = (STVALUEREC *)Malloc(sizeof(STVALUEREC));
  188.   newval->owner = OBJECTCLASS;
  189.   newval->vtype = SYM;
  190.   newval->UU.symval = s;
  191.   return newval;
  192. }  /* mkSYM */
  193.  
  194.  
  195. /* mkUSER - return a USER-type STVALUE                           */
  196. Static STVALUEREC *mkUSER(rho, ownr)
  197. ENVREC *rho;
  198. CLASSREC *ownr;
  199. {
  200.   STVALUEREC *newval;
  201.  
  202.   newval = (STVALUEREC *)Malloc(sizeof(STVALUEREC));
  203.   newval->vtype = USER;
  204.   newval->UU.userval = rho;
  205.   newval->owner = ownr;
  206.   return newval;
  207. }  /* mkUSER */
  208.  
  209.  
  210. /* mkExplist - return an EXPLIST with head e and tail el         */
  211. Static EXPLISTREC *mkExplist(e, el)
  212. EXPREC *e;
  213. EXPLISTREC *el;
  214. {
  215.   EXPLISTREC *newel;
  216.  
  217.   newel = (EXPLISTREC *)Malloc(sizeof(EXPLISTREC));
  218.   newel->head = e;
  219.   newel->tail = el;
  220.   return newel;
  221. }  /* mkExplist */
  222.  
  223.  
  224. /* mkNamelist - return a NAMELIST with head n and tail nl        */
  225. Static NAMELISTREC *mkNamelist(nm, nl)
  226. short nm;
  227. NAMELISTREC *nl;
  228. {
  229.   NAMELISTREC *newnl;
  230.  
  231.   newnl = (NAMELISTREC *)Malloc(sizeof(NAMELISTREC));
  232.   newnl->head = nm;
  233.   newnl->tail = nl;
  234.   return newnl;
  235. }  /* mkNamelist */
  236.  
  237.  
  238. /* mkValuelist - return an VALUELIST with head v and tail vl     */
  239. Static VALUELISTREC *mkValuelist(v, vl)
  240. STVALUEREC *v;
  241. VALUELISTREC *vl;
  242. {
  243.   VALUELISTREC *newvl;
  244.  
  245.   newvl = (VALUELISTREC *)Malloc(sizeof(VALUELISTREC));
  246.   newvl->head = v;
  247.   newvl->tail = vl;
  248.   return newvl;
  249. }  /* mkValuelist */
  250.  
  251.  
  252. /* mkEnv - return an ENV with vars nl and values vl              */
  253. Static ENVREC *mkEnv(nl, vl)
  254. NAMELISTREC *nl;
  255. VALUELISTREC *vl;
  256. {
  257.   ENVREC *rho;
  258.  
  259.   rho = (ENVREC *)Malloc(sizeof(ENVREC));
  260.   rho->vars = nl;
  261.   rho->values = vl;
  262.   return rho;
  263. }  /* mkEnv */
  264.  
  265.  
  266. /* lengthVL - return length of VALUELIST vl                      */
  267. Static long lengthVL(vl)
  268. VALUELISTREC *vl;
  269. {
  270.   long i;
  271.  
  272.   i = 0;
  273.   while (vl != NULL) {
  274.     i++;
  275.     vl = vl->tail;
  276.   }
  277.   return i;
  278. }  /* lengthVL */
  279.  
  280.  
  281. /* lengthNL - return length of NAMELIST nl                       */
  282. Static long lengthNL(nl)
  283. NAMELISTREC *nl;
  284. {
  285.   long i;
  286.  
  287.   i = 0;
  288.   while (nl != NULL) {
  289.     i++;
  290.     nl = nl->tail;
  291.   }
  292.   return i;
  293. }  /* lengthNL */
  294.  
  295.  
  296. /*****************************************************************
  297.  *                     NAME MANAGEMENT                           *
  298.  *****************************************************************/
  299.  
  300. /* fetchClass - get class definition of NAME cname               */
  301. Static CLASSREC *fetchClass(cname)
  302. short cname;
  303. {
  304.   CLASSREC *cl;
  305.   boolean found;
  306.  
  307.   found = false;
  308.   cl = classes;
  309.   while (cl != NULL && !found) {
  310.     if (cl->clname == cname)
  311.       found = true;
  312.     else
  313.       cl = cl->nextclass;
  314.   }
  315.   return cl;
  316. }  /* fetchClass */
  317.  
  318.  
  319. /* newClass - add new class cname to classes                     */
  320. Static CLASSREC *newClass(cname, super)
  321. short cname;
  322. CLASSREC *super;
  323. {
  324.   CLASSREC *cl;
  325.  
  326.   cl = fetchClass(cname);
  327.   if (cl == NULL) {   /* cname not yet defined as class */
  328.     cl = (CLASSREC *)Malloc(sizeof(CLASSREC));
  329.     cl->clname = cname;
  330.     cl->nextclass = classes;   /* place new CLASSREC */
  331.     classes = cl;   /* on classes list */
  332.   }
  333.   cl->clsuper = super;
  334.   return cl;
  335. }  /* newClass */
  336.  
  337.  
  338. /* fetchFun - get function definition of NAME fname from fenv    */
  339. Static FUNDEFREC *fetchFun(fname, fenv)
  340. short fname;
  341. FUNDEFREC *fenv;
  342. {
  343.   boolean found;
  344.  
  345.   found = false;
  346.   while (fenv != NULL && !found) {
  347.     if (fenv->funname == fname)
  348.       found = true;
  349.     else
  350.       fenv = fenv->nextfundef;
  351.   }
  352.   return fenv;
  353. }  /* fetchFun */
  354.  
  355.  
  356. /* newFunDef - add new function fname to fenv                    */
  357. Static FUNDEFREC *newFunDef(fname, fenv)
  358. short fname;
  359. FUNDEFREC **fenv;
  360. {
  361.   FUNDEFREC *f;
  362.  
  363.   f = fetchFun(fname, *fenv);
  364.   if (f != NULL)   /* fname not yet defined as a function */
  365.     return f;
  366.   f = (FUNDEFREC *)Malloc(sizeof(FUNDEFREC));
  367.   f->funname = fname;
  368.   f->nextfundef = *fenv;   /* place new FUNDEFREC */
  369.   *fenv = f;   /* on fenv list */
  370.   return f;
  371. }  /* newFunDef */
  372.  
  373.  
  374. /* initNames - place all pre-defined names into printNames       */
  375. Static Void initNames()
  376. {
  377.   long i;
  378.  
  379.   fundefs = NULL;
  380.   i = 1;
  381.   memcpy(printNames[i - 1], "if                            ",
  382.      sizeof(NAMESTRING));
  383.   i++;
  384.   memcpy(printNames[i - 1], "while                         ",
  385.      sizeof(NAMESTRING));
  386.   i++;
  387.   memcpy(printNames[i - 1], "set                           ",
  388.      sizeof(NAMESTRING));
  389.   i++;
  390.   memcpy(printNames[i - 1], "begin                         ",
  391.      sizeof(NAMESTRING));
  392.   i++;
  393.   memcpy(printNames[i - 1], "new                           ",
  394.      sizeof(NAMESTRING));
  395.   i++;
  396.   numCtrlOps = i - 1;
  397.   memcpy(printNames[i - 1], "+                             ",
  398.      sizeof(NAMESTRING));
  399.   i++;
  400.   memcpy(printNames[i - 1], "-                             ",
  401.      sizeof(NAMESTRING));
  402.   i++;
  403.   memcpy(printNames[i - 1], "*                             ",
  404.      sizeof(NAMESTRING));
  405.   i++;
  406.   memcpy(printNames[i - 1], "/                             ",
  407.      sizeof(NAMESTRING));
  408.   i++;
  409.   memcpy(printNames[i - 1], "=                             ",
  410.      sizeof(NAMESTRING));
  411.   i++;
  412.   memcpy(printNames[i - 1], "<                             ",
  413.      sizeof(NAMESTRING));
  414.   i++;
  415.   memcpy(printNames[i - 1], ">                             ",
  416.      sizeof(NAMESTRING));
  417.   i++;
  418.   memcpy(printNames[i - 1], "print                         ",
  419.      sizeof(NAMESTRING));
  420.   i++;
  421.   memcpy(printNames[i - 1], "self                          ",
  422.      sizeof(NAMESTRING));
  423.   SELF = i;
  424.   numNames = i;
  425.   numBuiltins = i - 1;
  426. }  /* initNames */
  427.  
  428.  
  429. Static jmp_buf _JL99;
  430.  
  431.  
  432. /* install - insert new name into printNames                     */
  433. Static short install(nm)
  434. Char *nm;
  435. {
  436.   long i;
  437.   boolean found;
  438.  
  439.   i = 1;
  440.   found = false;
  441.   while (i <= numNames && !found) {
  442.     if (!memcmp(nm, printNames[i - 1], sizeof(NAMESTRING)))
  443.       found = true;
  444.     else
  445.       i++;
  446.   }
  447.   if (found)
  448.     return i;
  449.   if (i > MAXNAMES) {
  450.     printf("No more room for names\n");
  451.     longjmp(_JL99, 1);
  452.   }
  453.   numNames = i;
  454.   memcpy(printNames[i - 1], nm, sizeof(NAMESTRING));
  455.   return i;
  456. }  /* install */
  457.  
  458.  
  459. /* prName - print name nm                                        */
  460. Static Void prName(nm)
  461. short nm;
  462. {
  463.   long i;
  464.  
  465.   i = 1;
  466.   while (i <= NAMELENG) {
  467.     if (printNames[nm - 1][i - 1] != ' ') {
  468.       putchar(printNames[nm - 1][i - 1]);
  469.       i++;
  470.     } else
  471.       i = NAMELENG + 1;
  472.   }
  473. }  /* prName */
  474.  
  475.  
  476. /* primOp - translate NAME optr to corresponding BUILTINOP       */
  477. Static BUILTINOP primOp(optr)
  478. short optr;
  479. {
  480.   BUILTINOP op;
  481.   long i;
  482.  
  483.   op = IFOP;   /* N.B. IFOP is first value in BUILTINOPS */
  484.   for (i = 1; i < optr; i++)
  485.     op = (BUILTINOP)((long)op + 1);
  486.   return op;
  487. }  /* primOp */
  488.  
  489.  
  490. /*****************************************************************
  491.  *                        INPUT                                  *
  492.  *****************************************************************/
  493.  
  494. /* isDelim - check if c is a delimiter                           */
  495. Static boolean isDelim(c)
  496. Char c;
  497. {
  498.   return (c == ';' || c == ' ' || c == ')' || c == '(');
  499. }  /* isDelim */
  500.  
  501.  
  502. /* skipblanks - return next non-blank position in userinput      */
  503. Static long skipblanks(p)
  504. long p;
  505. {
  506.   while (userinput[p - 1] == ' ')
  507.     p++;
  508.   return p;
  509. }  /* skipblanks */
  510.  
  511.  
  512. /* matches - check if string nm matches userinput[s .. s+leng]   */
  513. Static boolean matches(s, leng, nm)
  514. long s;
  515. char leng;
  516. Char *nm;
  517. {
  518.   boolean match;
  519.   long i;
  520.  
  521.   match = true;
  522.   i = 1;
  523.   while (match && i <= leng) {
  524.     if (userinput[s - 1] != nm[i - 1])
  525.       match = false;
  526.     i++;
  527.     s++;
  528.   }
  529.   if (!isDelim(userinput[s - 1]))
  530.     match = false;
  531.   return match;
  532. }  /* matches */
  533.  
  534.  
  535. /* nextchar - read next char - filter tabs and comments          */
  536. Local Void nextchar(c)
  537. Char *c;
  538. {
  539.   Char STR1[256];
  540.  
  541.   *c = getchar();
  542.   if (*c == '\n')
  543.     *c = ' ';
  544.   if (*c == (Char)TABCODE) {
  545.     *c = ' ';
  546.     return;
  547.   }
  548.   sprintf(STR1, "%c", *c);
  549.   if (strcmp(STR1, COMMENTCHAR))
  550.     return;
  551.   while (!P_eoln(stdin)) {
  552.     *c = getchar();
  553.     if (*c == '\n')
  554.       *c = ' ';
  555.   }
  556.   *c = ' ';
  557. }  /* nextchar */
  558.  
  559. /* readParens - read char's, ignoring newlines, to matching ')'  */
  560. Local Void readParens()
  561. {
  562.   long parencnt;   /* current depth of parentheses */
  563.   Char c;
  564.  
  565.   parencnt = 1;   /* '(' just read */
  566.   do {
  567.     if (P_eoln(stdin))
  568.       fputs(PROMPT2, stdout);
  569.     nextchar(&c);
  570.     pos_++;
  571.     if (pos_ == MAXINPUT) {
  572.       printf("User input too long\n");
  573.       longjmp(_JL99, 1);
  574.     }
  575.     userinput[pos_ - 1] = c;
  576.     if (c == '(')
  577.       parencnt++;
  578.     if (c == ')')
  579.       parencnt--;
  580.   } while (parencnt != 0);   /* readParens */
  581. }
  582.  
  583. Local Void readInput()
  584. {
  585.   Char c;
  586.  
  587.   fputs(PROMPT, stdout);
  588.   pos_ = 0;
  589.   do {
  590.     pos_++;
  591.     if (pos_ == MAXINPUT) {
  592.       printf("User input too long\n");
  593.       longjmp(_JL99, 1);
  594.     }
  595.     nextchar(&c);
  596.     userinput[pos_ - 1] = c;
  597.     if (userinput[pos_ - 1] == '(')
  598.       readParens();
  599.   } while (!P_eoln(stdin));
  600.   inputleng = pos_;
  601.   userinput[pos_] = ';';   /* sentinel */
  602. }  /* readInput */
  603.  
  604.  
  605. /* reader - read char's into userinput; be sure input not blank  */
  606. Static Void reader()
  607. {
  608.  
  609.   /* readInput - read char's into userinput                        */
  610.   do {
  611.     readInput();
  612.     pos_ = skipblanks(1L);   /* ignore blank lines */
  613.   } while (pos_ > inputleng);   /* reader */
  614. }
  615.  
  616.  
  617. /* parseName - return (installed) NAME starting at userinput[pos]*/
  618. Static short parseName()
  619. {
  620.   NAMESTRING nm;   /* array to accumulate characters */
  621.   char leng;   /* length of name */
  622.  
  623.   leng = 0;
  624.   while ((pos_ <= inputleng) & (!isDelim(userinput[pos_ - 1]))) {
  625.     if (leng == NAMELENG) {
  626.       printf("Name too long, begins: %.*s\n", NAMELENG, nm);
  627.       longjmp(_JL99, 1);
  628.     }
  629.     leng++;
  630.     nm[leng - 1] = userinput[pos_ - 1];
  631.     pos_++;
  632.   }
  633.   if (leng == 0) {
  634.     printf("Error: expected name, instead read: %c\n", userinput[pos_ - 1]);
  635.     longjmp(_JL99, 1);
  636.   }
  637.   for (; leng < NAMELENG; leng++)
  638.     nm[leng] = ' ';
  639.   pos_ = skipblanks((long)pos_);   /* skip blanks after name */
  640.   return (install(nm));
  641. }  /* parseName */
  642.  
  643.  
  644. Local boolean isDigits(pos)
  645. long pos;
  646. {
  647.   boolean Result;
  648.  
  649.   if (!isdigit(userinput[pos - 1]))
  650.     return false;
  651.   Result = true;
  652.   while (isdigit(userinput[pos - 1]))
  653.     pos++;
  654.   if (!isDelim(userinput[pos - 1]))
  655.     return false;
  656.   return Result;
  657. }  /* isDigits */
  658.  
  659. Local boolean isNumber(pos)
  660. long pos;
  661. {
  662.  
  663.   /* isDigits - check if sequence of digits begins at pos          */
  664.   return (isDigits(pos) | ((userinput[pos - 1] == '-') & isDigits(pos + 1)));
  665. }  /* isNumber */
  666.  
  667.  
  668. /* isValue - check if a number or quoted const begins at pos     */
  669. Static boolean isValue(pos)
  670. long pos;
  671. {
  672.  
  673.   /* isNumber - check if a number begins at pos                    */
  674.   return ((userinput[pos - 1] == '#') | isNumber(pos));
  675. }  /* isValue */
  676.  
  677.  
  678. Local long parseInt()
  679. {
  680.   long n, sign;
  681.  
  682.   n = 0;
  683.   sign = 1;
  684.   if (userinput[pos_ - 1] == '-') {
  685.     sign = -1;
  686.     pos_++;
  687.   }
  688.   while (isdigit(userinput[pos_ - 1])) {
  689.     n = n * 10 + userinput[pos_ - 1] - '0';
  690.     pos_++;
  691.   }
  692.   pos_ = skipblanks((long)pos_);   /* skip blanks after number */
  693.   return (n * sign);
  694. }  /* parseInt */
  695.  
  696.  
  697. /* parseVal - return primitive value starting at userinput[pos]  */
  698. Static STVALUEREC *parseVal()
  699. {
  700.  
  701.   /* parseInt - return number starting at userinput[pos]           */
  702.   if (userinput[pos_ - 1] == '#') {
  703.     pos_++;
  704.     return (mkSYM(parseName()));
  705.   } else
  706.     return (mkINT(parseInt()));
  707. }  /* parseVal */
  708.  
  709.  
  710. Static EXPLISTREC *parseEL PV();
  711.  
  712.  
  713. /* parseExp - return EXP starting at userinput[pos]              */
  714. Static EXPREC *parseExp()
  715. {
  716.   short nm;
  717.   EXPLISTREC *el;
  718.  
  719.   if (userinput[pos_ - 1] == '(') {  /* APEXP */
  720.     pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  721.     nm = parseName();
  722.     el = parseEL();
  723.     return (mkAPEXP(nm, el));
  724.   } else if (isValue((long)pos_))
  725.     return (mkVALEXP(parseVal()));   /* VALEXP */
  726.   else
  727.     return (mkVAREXP(parseName()));   /* VAREXP */
  728. }  /* parseExp */
  729.  
  730.  
  731. /* parseEL - return EXPLIST starting at userinput[pos]           */
  732. Static EXPLISTREC *parseEL()
  733. {
  734.   EXPREC *e;
  735.   EXPLISTREC *el;
  736.  
  737.   if (userinput[pos_ - 1] == ')') {
  738.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  739.     return NULL;
  740.   } else {
  741.     e = parseExp();
  742.     el = parseEL();
  743.     return (mkExplist(e, el));
  744.   }
  745. }  /* parseEL */
  746.  
  747.  
  748. /* parseNL - return NAMELIST starting at userinput[pos]          */
  749. Static NAMELISTREC *parseNL()
  750. {
  751.   short nm;
  752.   NAMELISTREC *nl;
  753.  
  754.   if (userinput[pos_ - 1] == ')') {
  755.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  756.     return NULL;
  757.   } else {
  758.     nm = parseName();
  759.     nl = parseNL();
  760.     return (mkNamelist(nm, nl));
  761.   }
  762. }  /* parseNL */
  763.  
  764.  
  765. /* parseDef - parse function definition at userinput[pos]        */
  766. Static short parseDef(fenv)
  767. FUNDEFREC **fenv;
  768. {
  769.   short fname;   /* function name */
  770.   FUNDEFREC *newfun;   /* new FUNDEFREC */
  771.  
  772.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  773.   pos_ = skipblanks(pos_ + 6L);   /* skip 'define ..' */
  774.   fname = parseName();
  775.   newfun = newFunDef(fname, fenv);
  776.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  777.   newfun->formals = parseNL();
  778.   newfun->body = parseExp();
  779.   pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  780.   return fname;
  781. }  /* parseDef */
  782.  
  783.  
  784. /* parseClass - parse class definition at userinput[pos]         */
  785. Static short parseClass()
  786. {
  787.   short cname, sname, fname;
  788.   CLASSREC *thisclass, *superclass;
  789.   NAMELISTREC *rep;
  790.   FUNDEFREC *cenv;
  791.  
  792.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  793.   pos_ = skipblanks(pos_ + 5L);   /* skip 'class ...' */
  794.   cname = parseName();
  795.   sname = parseName();
  796.   superclass = fetchClass(sname);
  797.   if (superclass == NULL) {
  798.     printf("Undefined superclass: ");
  799.     prName(sname);
  800.     putchar('\n');
  801.     longjmp(_JL99, 1);
  802.   }
  803.   thisclass = newClass(cname, superclass);
  804.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ...' */
  805.   rep = parseNL();   /* component names */
  806.   cenv = NULL;
  807.   while (userinput[pos_ - 1] == '(') {
  808.     fname = parseDef(&cenv);
  809.     prName(fname);
  810.     putchar('\n');
  811.   }
  812.   thisclass->exported = cenv;
  813.   if (rep == NULL)
  814.     thisclass->clrep = superclass->clrep;
  815.   else {
  816.     thisclass->clrep = rep;
  817.     while (rep->tail != NULL)
  818.       rep = rep->tail;
  819.     rep->tail = superclass->clrep;
  820.   }
  821.   pos_ = skipblanks(pos_ + 1L);   /* skip ' ..)' */
  822.   return cname;
  823. }  /* parseClass */
  824.  
  825.  
  826. /*****************************************************************
  827.  *                     ENVIRONMENTS                              *
  828.  *****************************************************************/
  829.  
  830. /* emptyEnv - return an environment with no bindings             */
  831. Static ENVREC *emptyEnv()
  832. {
  833.   return (mkEnv(NULL, NULL));
  834. }  /* emptyEnv */
  835.  
  836.  
  837. /* bindVar - bind variable nm to value n in environment rho      */
  838. Static Void bindVar(nm, v, rho)
  839. short nm;
  840. STVALUEREC *v;
  841. ENVREC *rho;
  842. {
  843.   rho->vars = mkNamelist(nm, rho->vars);
  844.   rho->values = mkValuelist(v, rho->values);
  845. }  /* bindVar */
  846.  
  847.  
  848. /* findVar - look up nm in rho                                   */
  849. Static VALUELISTREC *findVar(nm, rho)
  850. short nm;
  851. ENVREC *rho;
  852. {
  853.   NAMELISTREC *nl;
  854.   VALUELISTREC *vl;
  855.   boolean found;
  856.  
  857.   found = false;
  858.   nl = rho->vars;
  859.   vl = rho->values;
  860.   while (nl != NULL && !found) {
  861.     if (nl->head == nm)
  862.       found = true;
  863.     else {
  864.       nl = nl->tail;
  865.       vl = vl->tail;
  866.     }
  867.   }
  868.   return vl;
  869. }  /* findVar */
  870.  
  871.  
  872. /* assign - assign value n to variable nm in rho                 */
  873. Static Void assign(nm, v, rho)
  874. short nm;
  875. STVALUEREC *v;
  876. ENVREC *rho;
  877. {
  878.   VALUELISTREC *varloc;
  879.  
  880.   varloc = findVar(nm, rho);
  881.   varloc->head = v;
  882. }  /* assign */
  883.  
  884.  
  885. /* fetch - return number bound to nm in rho                      */
  886. Static STVALUEREC *fetch(nm, rho)
  887. short nm;
  888. ENVREC *rho;
  889. {
  890.   VALUELISTREC *vl;
  891.  
  892.   vl = findVar(nm, rho);
  893.   return (vl->head);
  894. }  /* fetch */
  895.  
  896.  
  897. /* isBound - check if nm is bound in rho                         */
  898. Static boolean isBound(nm, rho)
  899. short nm;
  900. ENVREC *rho;
  901. {
  902.   return (findVar(nm, rho) != NULL);
  903. }  /* isBound */
  904.  
  905.  
  906. /*****************************************************************
  907.  *                           VALUES                              *
  908.  *****************************************************************/
  909.  
  910. /* prValue - print value v                                       */
  911. Static Void prValue(v)
  912. STVALUEREC *v;
  913. {
  914.   if (v->vtype == INT) {
  915.     printf("%ld", v->UU.intval);
  916.     return;
  917.   }
  918.   if (v->vtype == SYM)
  919.     prName(v->UU.symval);
  920.   else
  921.     printf("<userval>");
  922. }  /* prValue */
  923.  
  924.  
  925. /* isTrueVal - return true if v is true (non-zero) value         */
  926. Static boolean isTrueVal(v)
  927. STVALUEREC *v;
  928. {
  929.   if (v->vtype == USER || v->vtype == SYM)
  930.     return true;
  931.   else
  932.     return (v->UU.intval != 0);
  933. }  /* isTrueVal */
  934.  
  935.  
  936. /* arity - return number of arguments expected by op             */
  937. Local long arity(op)
  938. BUILTINOP op;
  939. {
  940.   if (((1L << ((long)op)) & ((1 << ((long)GTOP + 1)) - (1 << ((long)PLUSOP)))) != 0)
  941.     return 2;
  942.   else
  943.     return 1;
  944. }  /* arity */
  945.  
  946.  
  947. /* applyValueOp - apply VALUEOP op to arguments in VALUELIST vl  */
  948. Static STVALUEREC *applyValueOp(op, vl)
  949. BUILTINOP op;
  950. VALUELISTREC *vl;
  951. {
  952.   long n, n1, n2;
  953.   STVALUEREC *s1, *s2;
  954.  
  955.   if (arity(op) != lengthVL(vl)) {
  956.     printf("Wrong number of arguments to ");
  957.     prName((int)op + 1);
  958.     putchar('\n');
  959.     longjmp(_JL99, 1);
  960.   }
  961.   s1 = vl->head;   /* 1st actual */
  962.   if (arity(op) == 2)   /* 2nd actual */
  963.     s2 = vl->tail->head;
  964.   if (op == PRINTOP) {
  965.     prValue(s1);
  966.     putchar('\n');
  967.     return s1;
  968.   } else if (op == EQOP) {
  969.     if (s1->vtype == s2->vtype) {
  970.       if (s1->vtype == INT && s1->UU.intval == s2->UU.intval ||
  971.       s1->vtype == SYM && s1->UU.symval == s2->UU.symval)
  972.     return trueValue;
  973.       else
  974.     return falseValue;
  975.     } else
  976.       return falseValue;
  977.   } else {
  978.     if (s1->vtype != INT || s2->vtype != INT) {
  979.       printf("Arguments to numeric op not integer: ");
  980.       prName((int)op+1);
  981.       putchar('\n');
  982.       longjmp(_JL99, 1);
  983.     }
  984.     n1 = s1->UU.intval;
  985.     n2 = s2->UU.intval;
  986.     switch (op) {
  987.  
  988.     case PLUSOP:
  989.       n = n1 + n2;
  990.       break;
  991.  
  992.     case MINUSOP:
  993.       n = n1 - n2;
  994.       break;
  995.  
  996.     case TIMESOP:
  997.       n = n1 * n2;
  998.       break;
  999.  
  1000.     case DIVOP:
  1001.       n = n1 / n2;
  1002.       break;
  1003.  
  1004.     case LTOP:
  1005.       if (n1 < n2)
  1006.     n = 1;
  1007.       else
  1008.     n = 0;
  1009.       break;
  1010.  
  1011.     case GTOP:
  1012.       if (n1 > n2)
  1013.     n = 1;
  1014.       else
  1015.     n = 0;
  1016.       break;
  1017.     }/* case */
  1018.     return (mkINT(n));
  1019.   }
  1020. }  /* applyValueOp */
  1021.  
  1022.  
  1023. Static STVALUEREC *eval PP((EXPREC *e, ENVREC *rho, STVALUEREC *rcvr));
  1024.  
  1025. /* Local variables for eval: */
  1026. struct LOC_eval {
  1027.   ENVREC *rho;
  1028.   STVALUEREC *rcvr;
  1029. } ;
  1030.  
  1031. /* evalList - evaluate each expression in el                     */
  1032. Local VALUELISTREC *evalList(el, LINK)
  1033. EXPLISTREC *el;
  1034. struct LOC_eval *LINK;
  1035. {
  1036.   STVALUEREC *h;
  1037.   VALUELISTREC *t;
  1038.  
  1039.   if (el == NULL)
  1040.     return NULL;
  1041.   else {
  1042.     h = eval(el->head, LINK->rho, LINK->rcvr);
  1043.     t = evalList(el->tail, LINK);
  1044.     return (mkValuelist(h, t));
  1045.   }
  1046. }  /* evalList */
  1047.  
  1048. /* applyGlobalFun - apply function defined at top level          */
  1049. Local STVALUEREC *applyGlobalFun(optr, actuals, LINK)
  1050. short optr;
  1051. VALUELISTREC *actuals;
  1052. struct LOC_eval *LINK;
  1053. {
  1054.   FUNDEFREC *f;
  1055.   ENVREC *rho;
  1056.  
  1057.   f = fetchFun(optr, fundefs);
  1058.   if (f == NULL) {
  1059.     printf("Undefined function: ");
  1060.     prName(optr);
  1061.     putchar('\n');
  1062.     longjmp(_JL99, 1);
  1063.   }
  1064.   if (lengthNL(f->formals) != lengthVL(actuals)) {
  1065.     printf("Wrong number of arguments to: ");
  1066.     prName(f->funname);
  1067.     putchar('\n');
  1068.     longjmp(_JL99, 1);
  1069.   }
  1070.   rho = mkEnv(f->formals, actuals);
  1071.   return (eval(f->body, rho, LINK->rcvr));   /* with */
  1072. }  /* applyGlobalFun */
  1073.  
  1074. /* methodSearch - find class of optr, if any, starting at cl     */
  1075. Local FUNDEFREC *methodSearch(optr, cl, LINK)
  1076. short optr;
  1077. CLASSREC *cl;
  1078. struct LOC_eval *LINK;
  1079. {
  1080.   FUNDEFREC *f;
  1081.  
  1082.   f = NULL;
  1083.   while (f == NULL && cl != NULL) {
  1084.     f = fetchFun(optr, cl->exported);
  1085.     if (f == NULL)
  1086.       cl = cl->clsuper;
  1087.   }
  1088.   return f;
  1089. }  /* methodSearch */
  1090.  
  1091. /* applyMethod - apply method f to actuals                       */
  1092. Local STVALUEREC *applyMethod(f, actuals, LINK)
  1093. FUNDEFREC *f;
  1094. VALUELISTREC *actuals;
  1095. struct LOC_eval *LINK;
  1096. {
  1097.   ENVREC *rho;
  1098.  
  1099.   if (lengthNL(f->formals) != lengthVL(actuals) - 1) {
  1100.     printf("Wrong number of arguments to: ");
  1101.     prName(f->funname);
  1102.     putchar('\n');
  1103.     longjmp(_JL99, 1);
  1104.   }
  1105.   rho = mkEnv(f->formals, actuals->tail);
  1106.   return (eval(f->body, rho, actuals->head));
  1107. }  /* applyMethod */
  1108.  
  1109. /* mkRepFor - make list of all zeros of same length as nl        */
  1110. Local VALUELISTREC *mkRepFor(nl)
  1111. NAMELISTREC *nl;
  1112. {
  1113.   if (nl == NULL)
  1114.     return NULL;
  1115.   else
  1116.     return (mkValuelist(falseValue, mkRepFor(nl->tail)));
  1117. }  /* mkRepFor */
  1118.  
  1119. /* applyCtrlOp - apply CONTROLOP op to args in rho               */
  1120. Local STVALUEREC *applyCtrlOp(op, args, LINK)
  1121. BUILTINOP op;
  1122. EXPLISTREC *args;
  1123. struct LOC_eval *LINK;
  1124. {
  1125.   STVALUEREC *Result, *v;
  1126.   CLASSREC *cl;
  1127.   STVALUEREC *newval;
  1128.   EXPLISTREC *WITH;
  1129.  
  1130.   WITH = args;
  1131.   switch (op) {
  1132.  
  1133.   case IFOP:
  1134.     if (isTrueVal(eval(WITH->head, LINK->rho, LINK->rcvr)))
  1135.       Result = eval(WITH->tail->head, LINK->rho, LINK->rcvr);
  1136.     else
  1137.       Result = eval(WITH->tail->tail->head, LINK->rho, LINK->rcvr);
  1138.     break;
  1139.  
  1140.   case WHILEOP:
  1141.     v = eval(WITH->head, LINK->rho, LINK->rcvr);
  1142.     while (isTrueVal(v)) {
  1143.       v = eval(WITH->tail->head, LINK->rho, LINK->rcvr);
  1144.       v = eval(WITH->head, LINK->rho, LINK->rcvr);
  1145.     }
  1146.     Result = v;
  1147.     break;
  1148.  
  1149.   case SETOP:
  1150.     v = eval(WITH->tail->head, LINK->rho, LINK->rcvr);
  1151.     if (isBound(WITH->head->UU.varble, LINK->rho))
  1152.       assign(WITH->head->UU.varble, v, LINK->rho);
  1153.     else if (isBound(WITH->head->UU.varble, LINK->rcvr->UU.userval))
  1154.       assign(WITH->head->UU.varble, v, LINK->rcvr->UU.userval);
  1155.     else if (isBound(WITH->head->UU.varble, globalEnv))
  1156.       assign(WITH->head->UU.varble, v, globalEnv);
  1157.     else
  1158.       bindVar(WITH->head->UU.varble, v, globalEnv);
  1159.     Result = v;
  1160.     break;
  1161.  
  1162.   case BEGINOP:
  1163.     while (args->tail != NULL) {
  1164.       v = eval(args->head, LINK->rho, LINK->rcvr);
  1165.       args = args->tail;
  1166.     }
  1167.     Result = eval(args->head, LINK->rho, LINK->rcvr);
  1168.     break;
  1169.  
  1170.   case NEWOP:
  1171.     /* Argument is a VAREXP with the name of a class */
  1172.     cl = fetchClass(args->head->UU.varble);
  1173.     newval = mkUSER(mkEnv(cl->clrep, mkRepFor(cl->clrep)), cl);
  1174.     assign(SELF, newval, newval->UU.userval);
  1175.     Result = newval;
  1176.     break;
  1177.   }/* case and with */
  1178.   return Result;
  1179. }  /* applyCtrlOp */
  1180.  
  1181.  
  1182. /*****************************************************************
  1183.  *                     EVALUATION                                *
  1184.  *****************************************************************/
  1185. /* eval - return value of e in environment rho, receiver rcvr    */
  1186. Static STVALUEREC *eval(e, rho_, rcvr_)
  1187. EXPREC *e;
  1188. ENVREC *rho_;
  1189. STVALUEREC *rcvr_;
  1190. {
  1191.   struct LOC_eval V;
  1192.   STVALUEREC *Result;
  1193.   VALUELISTREC *vl;
  1194.   FUNDEFREC *f;
  1195.  
  1196.   V.rho = rho_;
  1197.   V.rcvr = rcvr_;
  1198.   switch (e->etype) {
  1199.  
  1200.   case VALEXP:
  1201.     Result = e->UU.valu;
  1202.     break;
  1203.  
  1204.   case VAREXP:
  1205.     if (isBound(e->UU.varble, V.rho))
  1206.       Result = fetch(e->UU.varble, V.rho);
  1207.     else if (isBound(e->UU.varble, V.rcvr->UU.userval))
  1208.       Result = fetch(e->UU.varble, V.rcvr->UU.userval);
  1209.     else if (isBound(e->UU.varble, globalEnv))
  1210.       Result = fetch(e->UU.varble, globalEnv);
  1211.     else {
  1212.       printf("Undefined variable: ");
  1213.       prName(e->UU.varble);
  1214.       putchar('\n');
  1215.       longjmp(_JL99, 1);
  1216.     }
  1217.     break;
  1218.  
  1219.   case APEXP:
  1220.     if (e->UU.U2.optr <= numCtrlOps)
  1221.       Result = applyCtrlOp(primOp(e->UU.U2.optr), e->UU.U2.args, &V);
  1222.     else {
  1223.       vl = evalList(e->UU.U2.args, &V);
  1224.       if (lengthVL(vl) == 0)
  1225.     Result = applyGlobalFun(e->UU.U2.optr, vl, &V);
  1226.       else {
  1227.     f = methodSearch(e->UU.U2.optr, vl->head->owner, &V);
  1228.     if (f != NULL)
  1229.       Result = applyMethod(f, vl, &V);
  1230.     else if (e->UU.U2.optr <= numBuiltins)
  1231.       Result = applyValueOp(primOp(e->UU.U2.optr), vl);
  1232.     else
  1233.       Result = applyGlobalFun(e->UU.U2.optr, vl, &V);
  1234.       }
  1235.     }
  1236.     break;
  1237.   }/* case and with */
  1238.   return Result;
  1239. }  /* eval */
  1240.  
  1241.  
  1242. /*****************************************************************
  1243.  *                     READ-EVAL-PRINT LOOP                      *
  1244.  *****************************************************************/
  1245.  
  1246. /* initHierarchy - allocate class Object and create an instance  */
  1247. Static Void initHierarchy()
  1248. {
  1249.   classes = NULL;
  1250.   OBJECTCLASS = newClass(install("Object                        "), NULL);
  1251.   OBJECTCLASS->exported = NULL;
  1252.   OBJECTCLASS->clrep = mkNamelist(SELF, NULL);
  1253.   objectInst = mkUSER(mkEnv(OBJECTCLASS->clrep, mkValuelist(mkINT(0L), NULL)),
  1254.               OBJECTCLASS);
  1255. }  /* initHierarchy */
  1256.  
  1257.  
  1258. main(argc, argv)
  1259. int argc;
  1260. Char *argv[];
  1261. {  /* smalltalk main */
  1262.   PASCAL_MAIN(argc, argv);
  1263.   if (setjmp(_JL99))
  1264.     goto _L99;
  1265.   initNames();
  1266.   initHierarchy();
  1267.   globalEnv = emptyEnv();
  1268.  
  1269.   trueValue = mkINT(1L);
  1270.   falseValue = mkINT(0L);
  1271.  
  1272.   quittingtime = false;
  1273. _L99:
  1274.   while (!quittingtime) {
  1275.     reader();
  1276.     if (matches((long)pos_, 4, "quit                          ")) {
  1277.       quittingtime = true;
  1278.       break;
  1279.     }
  1280.     if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L), 6,
  1281.       "define                        ")) {
  1282.       prName(parseDef(&fundefs));
  1283.       putchar('\n');
  1284.     } else if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L),
  1285.          5, "class                         ")) {
  1286.       prName(parseClass());
  1287.       putchar('\n');
  1288.     } else {
  1289.       currentExp = parseExp();
  1290.       prValue(eval(currentExp, emptyEnv(), objectInst));
  1291.       printf("\n\n");
  1292.     }
  1293.   }  /* while */
  1294.   exit(0);
  1295. }  /* smalltalk */
  1296.  
  1297.  
  1298.  
  1299. /* End. */
  1300.